home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 007 / colors.arc / TARGET.PAS < prev   
Pascal/Delphi Source File  |  1985-12-19  |  2KB  |  111 lines
  1. const
  2.   _6845_Index = $3D4 ;
  3.   _6845_Data  = $3D5 ;
  4.   ModeControl = $3D8 ;
  5.   MaxC        = 6 ;
  6.  
  7. var
  8.   c         :char ;
  9.   screen    : array[0..7999,0..1] of byte absolute $B000:$8000 ;
  10.   screeni   : array[0..7999] of integer absolute $B000:$8000 ;
  11.   hue       : array[0..MaxC,0..MaxC,0..MaxC] of byte ;
  12.   inten     : array[0..MaxC,0..MaxC,0..MaxC] of byte ;
  13.   block     : array[1..18,1..22] of integer ;
  14.   colorfile : file of byte ;
  15.   blockfile : file of integer ;
  16.   box,boy   : integer ;
  17.  
  18. procedure SetColors ;
  19. var
  20.   r,g,b : integer ;
  21. begin
  22.   assign(colorfile,'COLOR.DAT');
  23.   reset(colorfile) ;
  24.   for r := 0 to MaxC do
  25.   begin
  26.     for g := 0 to MaxC do
  27.     begin
  28.       for b := 0 to MaxC do
  29.       begin
  30.         read(colorfile,hue[r,g,b]   );
  31.         read(colorfile,inten[r,g,b])  ;
  32.       end ;
  33.     end ;
  34.   end ;
  35.   Close(ColorFile) ;
  36. end ;
  37.  
  38. procedure VideoReg(reg,data:integer) ;
  39. begin
  40.   Port[_6845_Index]:=reg ;
  41.   Port[_6845_Data] :=data;
  42. end ;
  43.  
  44. procedure NoBlink ;
  45. begin
  46.   Port[ModeControl] := 9 ;
  47. end ;
  48.  
  49. procedure MultiColor ;
  50. begin
  51.   SetColors ;
  52.   TextMode(C80) ; {put into 80 colomn color mode}
  53.   VideoReg(4,$7F); {increase total lines to 255}
  54.   VideoReg(6,$64); {increase displayed lines to 200}
  55.   VideoReg(7,$70); {change sync position}
  56.   VideoReg(9,$03); {change to 4 scan lines high}
  57.   NoBlink ;
  58. end ;
  59.  
  60. procedure NormalColor ;
  61. begin
  62.   TextMode(C40) ;
  63.   TextMode(C80) ;
  64. end ;
  65.  
  66. procedure Beep ;
  67. begin
  68.   Sound(2000) ;
  69.   Delay(500) ;
  70.   NoSound ;
  71. end ;
  72.  
  73. function Shade(c:integer;n:real):integer ;
  74. var
  75.   sh : integer ;
  76. begin
  77.   Sh := c+round(abs(MaxC-c)*n) ;
  78.   if (sh<0) then shade := 0 else
  79.   if (sh>MaxC) then shade:=MaxC else
  80.   shade := sh ;
  81. end ;
  82.  
  83. procedure FillColor ;
  84. var
  85.   i,x,y,z,r :integer ;
  86.   red,grn,blu : integer ;
  87.   x2,y2 : integer ;
  88.   co,ch : byte ;
  89.   t: integer ;
  90.   th : real ;
  91. begin
  92.   for i := 1 to 7999 do
  93.   begin
  94.     x := i mod 80 ;
  95.     y := i div 80 ;
  96.     x2:=(((x-40)*3) div 2) ;
  97.     y2:=y-50 ;
  98.     z := abs((x2*x2+y2*y2)-100) ;
  99.     screen[i,1] := hue[(z div 140) mod 7,(z div 150) mod 7,(z div 20) mod 7] ;
  100.     screen[i,0] := inten[(z div 140) mod 7,(z div 150) mod 7,(z div 20) mod 7] ;
  101.   end ;
  102. end ;
  103.  
  104. BEGIN
  105.   Multicolor ;
  106.   FillColor ;
  107.   Beep ;
  108.   read(kbd,c) ;
  109.   NormalColor ;
  110. END.
  111.